home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / util.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  8.8 KB  |  396 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. /* translation of adautil.stl to c */
  11. #include "hdr.h"
  12. #include "vars.h"
  13. #include "arithprots.h"
  14. #include "miscprots.h"
  15. #include "smiscprots.h"
  16. #include "utilprots.h"
  17.  
  18. static Const adavall(Symbol, char *, int);
  19. static char *breakc(char *, int, char);
  20. static int spanc(char *, int, char *);
  21. static Const adavali(char *, int, char);
  22.  
  23. Const adaval(Symbol mde, char *number)                            /*;adaval*/
  24. {
  25.     /* In SETL 'OVERFLOW' is returned to indicate overflow. In C
  26.      * the global variable adaval_overflow is set to indicate overflow
  27.      * Since adaval is recursive, we initialize flag here and then call
  28.      * adavall to perform actual computation.
  29.      * Part of the recursive use also involves breaking up the original
  30.      * string into parts, or slices, so we represent the string as    
  31.      * both pointers to the first character and companion intger giving length.
  32.      */
  33.  
  34.     Const    result;
  35.  
  36.     adaval_overflow = FALSE;
  37.     result = adavall(mde, number, strlen(number));
  38.     return result;
  39. }
  40.  
  41. static Const adavall(Symbol mde, char *number, int numberl)        /*;adavall*/
  42. {
  43.     int    n, i, d, tn;
  44.     Const    result, cbse, lncon;
  45.     Rational    rn;
  46.     char    numsign = '+';
  47.     char    *numb, *b, *dc;
  48.     char    *t, *expnt, *wh, *fr;
  49.     int    expntl, whl, frl, bse, p, bl;
  50.     int    numbl, exp_sgn;
  51.     int    *ibse, *ln, *e, *dv;
  52.     static    char *conv = "0123456789ABCDEF";
  53.     char    *tstr;
  54.     int    tstrl;
  55.  
  56.     if (numberl < 0 || numberl > 1000)chaos("util: adavall ridiculous numberl");
  57.  
  58.     n = 0;
  59.     /* The setl sequence r = break(s, c) translates into C as follows:
  60.      *    t = breakc(s, sl, c);
  61.      *    if (t == (char *)0) { ...no match }
  62.      *    else {    match
  63.      *      r = s; rl = t - s;
  64.      *      s = t; sl -= rl;
  65.      *    }
  66.      */
  67.     numb = number;
  68.     numbl = numberl;
  69.     if (numb == (char *)0 || numbl == 0) {
  70.         adaval_overflow = TRUE;
  71.         return const_new(CONST_OM);
  72.     }
  73.     numsign = '0';
  74.     if (*numb == '+' || *numb == '-') {
  75.         numsign = *numb;
  76.         if (numbl == 1){ /* if only sign */
  77.             adaval_overflow = TRUE;
  78.             return const_new(CONST_OM);
  79.         }
  80.         numb++;
  81.     }
  82.     /* see if want integer and no base or exponent; if so, call adavali
  83.      * to do (much simpler) conversion.
  84.      */
  85.     /* if want integer and number is all digits and no possibility of
  86.      * overflow, call adavali to do conversion 
  87.      */
  88.     if (mde == symbol_integer && numbl > 0 && numbl <= 4
  89.       && spanc(numb, numbl, "0123456789") == numbl) {
  90.         result = adavali(numb, numbl, numsign);
  91.         return result;
  92.     }
  93.     /* Divide num into bse, num, and expnt:*/
  94.  
  95.     t = breakc(numb, numbl, '#');
  96.     if (t == (char *)0) {    /* Not a based number.*/
  97.         bse   = 10;
  98.         expnt = numb; 
  99.         expntl = numbl;
  100.         t   = breakc(expnt, expntl, 'E');
  101.         if (t == (char*)0) {    /* No exponent.*/
  102.             numb   = expnt;
  103.             numbl   = expntl;
  104.             expnt = (char *)0;
  105.         }
  106.         else {            /* Exponent.*/
  107.             b = expnt; 
  108.             bl = t - expnt;
  109.             numb = b; 
  110.             numbl = bl;  /* do we need both ??  (gs 18-feb-85) */
  111.             expnt = t;
  112.             expntl -= bl;
  113.             expnt++; 
  114.             expntl--;
  115.         }
  116.     }
  117.     else {        /* Based number.*/
  118.         b = numb; 
  119.         bl = t - numb;
  120.         numb = t; 
  121.         numbl -= bl;
  122.         cbse   = adavali( b, bl, '+');
  123.         bse = cbse->const_value.const_int;
  124.         if (numbl > 0) {
  125.             expnt = numb+1; 
  126.             expntl = numbl-1;
  127.         }
  128.         else {
  129.             expnt = (char *)0;
  130.         }
  131.         t   = breakc(expnt, expntl, '#'); /* strip off right base delimiter. */
  132.         if (t != (char *)0) {
  133.             numb = expnt; 
  134.             numbl = t - expnt;
  135.             expnt = t; 
  136.             expntl -= numbl;
  137.         }
  138.         if (expntl == 1     && *expnt == 'E') {    /* No exponent. */
  139.             expnt = (char *)0;
  140.         }
  141.         else {            /* Exponent. */
  142.             if (expntl > 2) {
  143.                 expnt += 2; 
  144.                 expntl -= 2;
  145.             }
  146.             else {
  147.                 expnt = (char *)0;
  148.             }
  149.         }
  150.     }
  151.  
  152.     /* Compute exponent and bse ** expnt */
  153.  
  154.     ibse = int_fri(bse);
  155.     if (expnt != (char *)0) {
  156.         exp_sgn = 1;
  157.         if (*expnt == '+') {
  158.             if (expntl > 1) {
  159.                 expnt += 1; 
  160.                 expntl--;
  161.             }
  162.             else {
  163.                 expnt = (char *)0;
  164.             }
  165.         }
  166.         else if (*expnt == '-') {
  167.             if (expntl > 1) {
  168.                 expnt += 1; 
  169.                 expntl--;
  170.             }
  171.             else {
  172.                 expnt = (char *)0;
  173.             }
  174.             exp_sgn = -1;
  175.         }
  176.         result = adavall(symbol_universal_integer, expnt, expntl);
  177.         e = int_exp(ibse, result->const_value.const_uint);
  178.     }
  179.     else {
  180.         e = int_fri(1);
  181.         exp_sgn = 0;
  182.     }
  183.  
  184.     /* Now find the value of the number with base bse. */
  185.  
  186.     if (mde == symbol_integer || mde == symbol_universal_integer) {
  187.  
  188.         /* First convert body of integer: */
  189.  
  190.         ln      = int_fri(0);
  191.         for (i = 0; i < numbl; i++) {
  192.             dc = breakc(conv, 16, numb[i]);
  193.             if (dc == (char *)0) {
  194.                 adaval_overflow = TRUE;
  195.                 return (mde == symbol_integer ? int_const(0)
  196.                   : uint_const(int_con(0)));
  197.             }
  198.             d = dc - conv;
  199.             if (d > bse) {
  200.                 adaval_overflow = TRUE;
  201.                 return (mde == symbol_integer ? int_const(0)
  202.                   : uint_const(int_con(0)));
  203.             }
  204.             arith_overflow = FALSE;
  205.             ln = int_add(int_mul(ln, ibse), int_fri(d));
  206.             if (arith_overflow) {
  207.                 adaval_overflow = TRUE;
  208.                 arith_overflow = 0;
  209.                 return (mde == symbol_integer ? int_const(0)
  210.                   : uint_const(int_con(0)));
  211.             }
  212.         }
  213.  
  214.         /* Apply exponent:     (n := n * e) */
  215.  
  216.         if (exp_sgn == 1) {
  217.             ln = int_mul(ln, e);
  218.             if (arith_overflow) {
  219.                 adaval_overflow = TRUE;
  220.                 arith_overflow = FALSE; /* reset */
  221.                 return (mde == symbol_integer ? int_const(0)
  222.                   : uint_const(int_con(0)));
  223.             }
  224.         }
  225.  
  226.         /* If regular integer, then convert. */
  227.  
  228.         if (mde == symbol_integer) {
  229.             n = int_toi (ln);
  230.             if (arith_overflow) {
  231.                 adaval_overflow = TRUE;
  232.                 arith_overflow = FALSE; /* reset */
  233.                 return (mde == symbol_integer ? int_const(0)
  234.                   : uint_const(int_con(0)));
  235.             }
  236.             if (numsign == '-') n = -n;
  237.             result = int_const(n);
  238.         }
  239.         else {
  240.             result = uint_const(ln);
  241.         }
  242.  
  243.     }
  244.     else if (mde == symbol_float || mde == symbol_dfixed
  245.       || mde == symbol_universal_real) {
  246.  
  247.         /* To obtain the numerator of the rational number,
  248.          * concatenate whole part with fractional part and convert
  249.          * the whole thing as an integer.  Then the denominator is
  250.          * just the base raised to a power determined by the
  251.          * length of the fractional part.
  252.          */
  253.         tn = spanc(numb, numbl, "0123456789ABCDEFEabcdef");
  254.         if (tn > 0) {
  255.             wh = numb; 
  256.             whl = tn;
  257.             numb += tn; 
  258.             numbl -= tn;
  259.         }
  260.         else {
  261.             wh = (char *)0; 
  262.             whl = 0;
  263.         }
  264.         if (*numb == '.' ) {
  265.             if (numbl > 1) {
  266.                 numb++; 
  267.                 numbl--;
  268.             }
  269.             else {
  270.                 numb = (char *)0;
  271.             }
  272.  
  273.             tn   = spanc(numb, numbl, "0123456789ABCDEFabcdef");
  274.             if (tn == 0) {
  275.                 fr = (char *)0; 
  276.                 frl = 0;
  277.             }
  278.             else {
  279.                 fr = numb; 
  280.                 frl = tn;
  281.                 numb += tn; 
  282.                 numbl -= tn;
  283.             }
  284.             p    = frl;
  285.             /*wh = strjoin(wh, fr);*/
  286.             if (whl == 0 && frl == 0) {
  287.                 wh = "";
  288.             }
  289.             else if (whl == 0) { /* result is fr */
  290.                 wh = substr(fr, 1, frl);
  291.             }
  292.             else if (frl == 0) { /* result is wh */
  293.                 wh = substr(wh, 1, whl);
  294.             }
  295.             else { /* result is concaenation */
  296.                 wh = strjoin(substr(wh, 1, whl), substr(fr, 1, frl));
  297.             }
  298.             whl += frl;
  299.             /* TBSL: need to free up intermediate storge */
  300.         }
  301.         else {
  302.             p    = 0;
  303.         }
  304.         tstrl = 2 + 1 + whl + 1;
  305. #ifdef SMALLOC
  306.         tstr = smalloc((unsigned)tstrl+1);
  307. #else
  308.         tstr = emalloc((unsigned)tstrl+1);
  309. #endif
  310.         sprintf(tstr, "%2d#%s#", bse, wh);
  311.         lncon = adavall (symbol_universal_integer, tstr, tstrl);
  312. #ifndef SMALLOC
  313.         efree(tstr);
  314. #endif
  315.         dv = int_exp(ibse, int_fri(p));
  316.         if (lncon->const_kind == CONST_UINT) {
  317.             rn = rat_fri(lncon->const_value.const_uint, dv);
  318.         }
  319.         else if (lncon->const_kind == CONST_INT) {
  320.             rn = rat_fri(int_fri(lncon->const_value.const_int), dv);
  321.         }
  322.         else {
  323.             chaos("adavall: lncon wrong type");
  324.         }
  325.  
  326.         /* Apply exponent:     (n := n * e) */
  327.  
  328.         if (exp_sgn == 1) {
  329.             rn= rat_mul(rn, rat_fri(e, int_fri(1)));
  330.         }
  331.         else if (exp_sgn == -1) {
  332.             rn= rat_mul(rn, rat_fri(int_fri(1), e));
  333.         }
  334.  
  335.         /* If regular real, then convert. */
  336.  
  337.         if (mde == symbol_float) {
  338.             result = real_const(rat_tor (rn, ADA_REAL_DIGITS));
  339.         }
  340.         else {
  341.             result = rat_const(rn);
  342.         }
  343.     }
  344.     return result;
  345. }
  346.  
  347. static char *breakc(char *s, int sl, char c)                        /*;breakc*/
  348. {
  349.     /* look for instance of break character in search string. return
  350.      * null pointer if no instance, else pointer to first instance of
  351.      * break character.
  352.      */
  353.  
  354.     while (sl--) {
  355.         if (*s == c) return s;
  356.         s++;
  357.     }
  358.     return (char *)0;
  359. }
  360.  
  361. static int spanc(char *string, int length, char *span_string)        /*;spanc*/
  362. {
  363.     /* return number of initial characters in s which are also in ss */
  364.  
  365.     int        i, res = 0, ssl;
  366.     char    c;
  367.  
  368.     ssl = strlen(span_string);
  369.     for (i = 0; i < length; i++) {
  370.         c = string[i];
  371.         if (breakc(span_string, ssl, c) == (char *)0)
  372.             return i;
  373.         else res++;
  374.     }
  375.     return res;
  376. }
  377.  
  378. static Const adavali(char *number, int numberl, char numsign)        /*;adavali*/
  379. {
  380.     /* process conversion when ordinary integer wanted and no base or
  381.      * exponent, and NO possibility of overflow during conversion.
  382.      */
  383.  
  384.     Const    result;
  385.     int    i;
  386.     char    s[120]; /*TBSL: const. 120 should be prog param*/
  387.  
  388.     for (i = 0; i < numberl; i++)
  389.         s[i] = number[i];
  390.     s[numberl] = '\0';
  391.     i = atoi(s);
  392.     if (numsign == '-') i = -i;
  393.     result = int_const(i);
  394.     return result;
  395. }
  396.